
; Optimizations are marked with +++, and may be flushed if desired.

  
(define (compile-frame node depth frame cont)
    (compile node depth frame cont))

; Main dispatch for compiling a single expression.

(define (compile node depth frame cont)
  (let ((node (type-check node)))
    ((operator-table-ref compilators (node-operator-id node))
     node
     depth
     frame
     cont)))

; Specialists

(define compilators
  (make-operator-table
    (lambda (node depth frame cont)
      (generate-trap depth
		     frame
		     cont
		     "not valid in expression context"
		     (schemify node)))))

(define (define-compilator name type proc)
  (operator-define! compilators name type proc))

;----------------------------------------------------------------


(define-compilator 'literal 'leaf
  (lambda (node depth frame cont)
    (compile-constant (node-form node) depth frame cont)))

(define-compilator 'quote syntax-type
  (lambda (node depth frame cont)
    (compile-constant (cadr (node-form node)) depth frame cont)))

(define (compile-constant obj depth frame cont)
  (if (ignore-values-cont? cont)
      empty-segment
      (let ((out-register (get/allocate-out-register frame cont)))
        (deliver-register-value
          (cond ((eq? obj #f)
                 ;; +++ hack for bootstrap from Schemes that don't
                 ;; distinguish #f/()
                 (instruction (enum op false) out-register))
                ((small-integer? obj)
                 (integer-literal-instruction out-register obj))
                (else
                 (register-indirect-instruction
                   out-register
                   (frame-template-index frame)
                   (literal->index frame obj))))
          out-register frame cont))))

                                                

(define (small-integer? obj)
  (and (integer? obj)
       (exact? obj)
       (<= 0 (+ obj 128))
       (< (+ obj 128) byte-limit)))

; PreScheme does not have signed bytes so we bias OBJ

(define (integer-literal-instruction register obj)
  (instruction (enum op integer-literal)
               register
	       (+ obj 128)))


(define-compilator 'unspecific (proc () unspecific-type)  
  (lambda (node depth frame cont)
    (if (ignore-values-cont? cont)
        empty-segment
        (let ((out-register (get/allocate-out-register frame cont)))
          (deliver-register-value
            (instruction (enum op unspecific) out-register)
            out-register frame cont)))))   


(define-compilator 'unassigned (proc () unspecific-type)
  (lambda (node depth frame cont)
    (if (ignore-values-cont? cont)
        empty-segment
        (let ((out-register (get/allocate-out-register frame cont)))
          (deliver-register-value
            (instruction (enum op unassigned) out-register)
            out-register frame cont)))))                

  
;----------------------------------------------------------------
; Variable reference

(define-compilator 'name 'leaf
  (lambda (node depth frame cont)
    (let* ((binding (name-node-binding node))
	   (name (node-form node)))
      (if (pair? binding)
          (compile-local-name node name binding frame depth cont)
          (let ((out-register (get/allocate-out-register frame cont))
             	(index (binding->index frame binding name #f)))
            (deliver-register-value
	      (instruction (enum op global)
	                   out-register
			   (frame-template-index frame)
			   (high-byte index)
			   (low-byte index))
	      out-register frame cont))))))           


(define (compile-local-name node name binding frame depth cont)
  (let ((in-register (car binding))
	(rest (cdr binding)))
    (cond ((null? rest)		; in this frame, we can directly deliver that register
           (if (and (register-cont? cont) (register-cont-register cont))
             (let ((out-register (register-cont-register cont)))               
               (deliver-register-value
                 (move-instruction out-register in-register) ; The caller provided an output register so a move instruction is needed to honor that
               out-register frame cont))
             (begin
               (add-register-reference frame in-register) ; prevent the caller from freeing this register
               (deliver-register-value empty-segment in-register frame cont))))
	  ((null? (cdr rest))
	   (let ((out-register (get/allocate-out-register frame cont)))
	     (deliver-register-value
	       (register-indirect-instruction out-register in-register (car rest))
	       out-register frame cont)))
	  (else
	   (assertion-violation 'compile-local-name "variable has too many indirections"
				name binding)))))

; the registers are limited to 1 byte anyway, but the index can be two-byte
;
(define (register-indirect-instruction out-register in-register index)
  (if (> in-register 255)
      (assertion-violation 'register-indirect-instruction "index out of register range" in-register))
  (if (< index byte-limit)
    (instruction (enum op register-indirect) out-register in-register index)
    (instruction (enum op big-register-indirect) out-register in-register (high-byte index) (low-byte index))))


;----------------------------------------------------------------
; Assignment

(define-compilator 'set! syntax-type
  (lambda (node depth frame cont)
    (let* ((exp (node-form node))
	   (lhs-node (cadr exp))
	   (name (node-form lhs-node))
	   (binding (name-node-binding lhs-node))
	   (out-register (get/allocate-out-register frame cont))
	   (arg-cont (named-register-cont name)))
      (deliver-register-value
        (sequentially
          (compile (caddr exp) depth frame arg-cont)
          (if (pair? binding)
	      (let ((rest (cdr binding)))
		(if (null? rest)  ; in this frame
		    (move-instruction (car binding) (register-cont-register arg-cont)) ; copy the register content to the bindings index
		    (assertion-violation 'set! "SET! on a closed-over variable" name)))
	      (let ((index (binding->index frame
		 		           binding
					   name
					   #t)))
		(instruction (enum op set-global!)
		             out-register 
		             (register-cont-register arg-cont) 
		             (frame-template-index frame)
			     (high-byte index)
			     (low-byte index))))
	  (clear-register-cont frame arg-cont))
	out-register frame cont))))

(define (move-instruction out-register in-register)
  (if (= out-register in-register) ; this can happen
      empty-segment
      (instruction (enum op move) out-register in-register)))

;----------------------------------------------------------------
; IF and BEGIN

; Different continuations need a different kind of code here:
;
; return-cont
;  - need to pass the original cont to consequent & alternate
;    (to correctly handle things like (values ..) inside an if)
;  - can ommit any jumps to a join label (as a return is generated anyway)
;
; register-cont
;  - here we cannot pass the original cont to consequent and alternate as it would
;    result in two different output registers!
;  - so create two new continuations but pass them a common output register
;    for their output (which is the output of the entire if then) to avoid extra move 
;    instructions
;  -> This way there is only a move when it is really needed (if the value of the
;     consequent or alternative is a local binding (see compile-local-name)
;
; ignore-values-cont
;  - need to pass the original onward, as creating a new one-value cont would be wrong here 
;    (this is important if the somewhere inside the if is a "(values)" call.
;  - need to add a jump to the join label
;
(define-compilator 'if syntax-type
  (lambda (node depth frame cont)
    (let* ((exp (node-form node))
           (alt-label (make-label))
           (join-label (make-label))
           (test-cont (register-cont node 1))
           (test-code (sequentially
                        (compile (cadr exp) depth frame test-cont)
                        (instruction-using-label (enum op jump-if-false) alt-label (register-cont-register test-cont))
                        (clear-register-cont frame test-cont))))
      (cond 
        ((return-cont? cont)
         (sequentially
           test-code           
           (compile (caddr exp) depth frame cont)                             ;; Consequent
           (attach-label alt-label (compile (cadddr exp) depth frame cont)))) ;; Alternate        
        ((ignore-values-cont? cont)
         (sequentially
           test-code
           (compile (caddr exp) depth frame cont)                             ;; Consequent
           (instruction-using-label (enum op jump) join-label)
           (attach-label alt-label (compile (cadddr exp) depth frame cont))   ;; Alternate
           (attach-label join-label empty-segment)))
        ((register-cont? cont)
         (let* ((out-register (get/allocate-out-register frame cont))
                (cons-cont (register-cont node 2 out-register)) ; tell the compilators to deliver their value here instead of allocating a register
                (alt-cont  (register-cont node 3 out-register)))
           (sequentially
             test-code
             ;; Consequent
             (compile (caddr exp) depth frame cons-cont)
             (instruction-using-label (enum op jump) join-label)      
             ;; Alternate       
             (attach-label alt-label (compile (cadddr exp) depth frame alt-cont))
             ;; Join
             (attach-label join-label
                           (deliver-register-value empty-segment out-register frame cont)))))     
        (else
	  (assertion-violation 'if-compilator "unknown compiler continuation" cont))))))          
          
          
          
(define-compilator 'begin syntax-type
  (lambda (node depth frame cont)
    (let ((exp-list (cdr (node-form node))))
      (if (null? exp-list)
	  (generate-trap depth frame cont "null begin")
	  (let ((dummy
		 (make-node operator/begin ;For debugging database
			    `(begin ,@exp-list))))
	    (let loop ((exp-list exp-list) (i 1))
	      (if (null? (cdr exp-list))
		  (compile (car exp-list) depth frame cont)
		  (sequentially
		    (compile (car exp-list)
			     depth
			     frame
			     (ignore-values-cont dummy i))
		    (loop (cdr exp-list) (+ i 1))))))))))

;----------------------------------------------------------------
; Calls

(define (compile-call node depth frame cont)
  (if (node-ref node 'type-error)
      (compile-unknown-call node depth frame cont)
      (let ((proc-node (car (node-form node))))
	(cond ((name-node? proc-node)
	       (compile-name-call node proc-node depth frame cont))
	      ((and (lambda-node? proc-node)
		    (not (n-ary? (cadr (node-form proc-node)))))
	       (compile-redex proc-node (cdr (node-form node))
			      depth
			      frame
			      cont))
 	      ((and (literal-node? proc-node)
 		    (primop? (node-form proc-node)))
 	       (let ((primop (node-form proc-node)))
 		 (if (primop-compilator primop)
 		     ((primop-compilator primop) node depth frame cont)
 		     (assertion-violation 'compile-call
					  "compiler bug: primop has no compilator"
 			    primop
 			    (schemify node)))))
	      (else
	       (compile-unknown-call node depth frame cont))))))

(define-compilator 'call 'internal compile-call)

(define (compile-name-call node proc-node depth frame cont)
  (let ((binding (name-node-binding proc-node)))
    (if (binding? binding)
	(let ((static (binding-static binding)))
	  (cond ((primop? static)
		 (if (primop-compilator static)
		     ((primop-compilator static) node depth frame cont)
		     (compile-unknown-call node depth frame cont)))
		((transform? static)
		 (let* ((form (node-form node))
			(new (apply-inline-transform static
						     form
						     (node-form proc-node))))
		   (if (eq? new form)
		       (compile-unknown-call node depth frame cont)
		       (compile new depth frame cont))))
		(else
		 (compile-unknown-call node depth frame cont))))
	(compile-unknown-call node depth frame cont))))

; Compile a call to a computed procedure.

(define (compile-unknown-call node depth frame cont)
  (let* ((exp (node-form node))
         (nargs (length (cdr exp)))
         (proc-cont (register-cont node 0)))  
    (receive (before depth label after)
        (maybe-push-continuation depth frame cont node (not (can-do-register-call? nargs)))
      (if (can-do-register-call? nargs)
        (receive (code in-registers) 
            (compile-arguments-to-registers node (cdr exp) depth frame)
          (sequentially before
                        code
                        (compile (car exp) depth frame proc-cont)
                        (register-call-instruction (register-cont-register proc-cont)
                                                   depth frame label in-registers)
                        (apply free-register frame in-registers)
                        (clear-register-cont frame proc-cont)
                        after))                                      
        (sequentially before                    
	  	      (push-arguments node (cdr exp) 1 depth frame)
		      (compile (car exp) (+ depth nargs) frame proc-cont)		    
		      (call-instruction (register-cont-register proc-cont)
		                        nargs (+ depth nargs) frame label)
		      (clear-register-cont frame proc-cont)
		      after)))))


; A redex is a call of the form ((lambda (x1 ... xn) body ...) e1 ... en).

(define (compile-redex proc-node args depth frame cont)
  (let* ((proc-exp (node-form proc-node))
	 (formals (cadr proc-exp))
	 (body (caddr proc-exp)))
    (cond ((not (= (length formals)
		   (length args)))
	   (generate-trap depth
			  frame
			  cont
			  "wrong number of arguments"
			  (cons (schemify proc-node)
				(map schemify args))))
	  ((null? formals)
	   (compile body depth frame cont)) ;+++
	  (else
	   (let loop ((args args) (names formals) (rev-registers '()) (code empty-segment))
	     (if (null? args)
	         (begin
	           (set-frame-register-locations! frame formals (reverse rev-registers))
	           (sequentially
	             code
	             (compile-inline-body (reverse rev-registers)
		            		  (map name-node->symbol formals)
				          body
				          depth
				          frame
				          cont)))
		 ; Here we provide an allocated register for the output, as it will become
		 ; the place for the new binding. Providing no register could mean that the
		 ; compilator returns the index of another binding or function parameter which
		 ; we cannot reuse for this.
	         (let* ((arg-reg  (allocate-register frame))
	                (arg-cont (named-register-cont (node-form (car names)) arg-reg))
	                (arg-code (compile (car args) depth frame arg-cont)))
	           (loop (cdr args)
	                 (cdr names)
	                 (cons arg-reg rev-registers)
	                 (sequentially code arg-code)))))))))	                     
		                                         

(define (compile-inline-body registers formals body depth frame cont)
  (sequentially 
    (note-environment
      formals
      registers
      (compile body depth frame cont))
    (if (return-cont? cont)
        empty-segment
        (apply free-register frame registers))))


;----------------------------------------------------------------
; (PURE-LETREC ((<var> <val>) ...) (<free var> ...) <body>)
; These are LETREC's where the values are all LAMBDA's.  They are produced by
; opt/flatten.scm. 

(define-compilator 'pure-letrec syntax-type
  (lambda (node depth frame cont)
    (let* ((exp (node-form node))
           (specs (cadr exp))
           (free-vars (caddr exp))
           (body (cadddr exp))
           (count (length specs))
	   (old-locations (map name-node-binding free-vars))
	   (env-register  (allocate-register frame)))	 
      (receive (env-code ignore-free-vars-in-order)
          (compile-recursive-environment free-vars
					 depth
					 (frame-template-index frame) 
					 (letrec-template-maker specs frame) frame
					 env-register) 
	(for-each (lambda (node location)
		    (node-set! node 'binding location))
		  free-vars
		  old-locations)
	(set-lexical-offsets! (map car specs) env-register)
	(sequentially
	  env-code
	  (compile-inline-body (list env-register) ; this will free the env-register
			       (list (map name-node->symbol
					  (append (map car specs)
					  	  free-vars)))
			       body
			       depth
			       frame
			       cont))))))

; After getting the free variable list (to pass to NOTE-ENVIRONMENT) this
; compiles the values in SPECS, all of which are lambdas.  It returns the
; template indexes of the resulting templates.

(define (letrec-template-maker specs frame)
  (lambda (free-vars-in-order)
    (let ((all-vars (append (map car specs)
			    free-vars-in-order)))
      (map (lambda (spec)
	     (receive (proc-code proc-frame)
		 (compile-lambda (unflatten-form (cadr spec))
				 all-vars
				 (node-form (car spec))
				 #f
				 frame)
	       (literal->index frame
			       (segment->template proc-code proc-frame))))
	   specs))))

;----------------------------------------------------------------
; We don't pass the incremented depth to MAKE-RETURN-POINT because the
; return-pointer is not included in a continuation's size.
;
; Returns before-segment new-depth label after-segment.
;
; In all of these NODE is the expression whose value will be returned to the
; continuation.  It is saved for debugging assistance.
;
; push-false? specifies wether an empty slot should be pushed
; on the stack for the continuation to be filled in by the call.
; (register-call pushes this itself)

(define (maybe-push-continuation depth frame cont node push-false?)
  (if (return-cont? cont)
      (values empty-segment depth #f empty-segment)
      (push-continuation depth frame cont node push-false?)))

(define (push-continuation depth frame cont node push-false?)
  (if (return-cont? cont)
      (assertion-violation 'push-continuation "making a return point in tail position" cont))
  (let* ((out-register (if (ignore-values-cont? cont)
                           #f
                           (get/allocate-out-register frame cont)))
         (protocol (if (ignore-values-cont? cont)
                       (continuation-protocol 0 #t #f)
                       (continuation-protocol 1 #f out-register))))
    (if (register-cont? cont)
        (set-register-cont-register! cont out-register))
    (really-push-continuation depth frame protocol node cont push-false?)))

(define (push-continuation-no-protocol depth frame node cont push-false?)
  (really-push-continuation depth frame empty-segment node cont push-false?))

(define (really-push-continuation depth frame protocol node cont push-false?)
  (let ((more-depth (if push-false? 1 0)))
    (depth-check! frame (+ depth more-depth))
    (let ((label (make-label))
	  (protocol (if (keep-source-code?)
		        (note-source-code (fixup-source node
						        (cont-source-info cont))
					  protocol
					  frame)
		        protocol)))
      (values (if push-false? 
                  (instruction (enum op push-false))
                  empty-segment)
	      (+ depth more-depth)
	      label
	      (sequentially (continuation-data #f depth frame)
			    (attach-label label protocol))))))

(define (fixup-source node destination)
  ;; Abbreviate this somehow?
  (if node
      (if (pair? destination)
	  (cons (schemify node)
		(cons (car destination)
		      (schemify (cdr destination))))
	  (list (schemify node)))
      #f))
      

;----------------------------------------------------------------
; Compiling arguments

(define (get/allocate-out-register frame cont)
  (if (and (register-cont? cont)
           (register-cont-register cont))
      (register-cont-register cont)
      (allocate-register frame)))

; Compiles all arguments to registers and reserves an out-register 
; The returned registers must be freed
;
; returns (values code out-register in-registers)
(define (compile-to-registers node depth frame cont)
  (let ((args (cdr (node-form node)))
        (out-register (get/allocate-out-register frame cont)))
    (receive (code in-registers)
      (compile-arguments-to-registers node args depth frame)
      (values code out-register in-registers))))

; Compiles a list of arguments to registers. The returned registers must be freed
;
; returns (values code in-registers)
(define (compile-arguments-to-registers node args depth frame)
  (let loop ((args args) (i 1) (rev-registers '()) (code empty-segment))
    (if (null? args)
        (values code (reverse rev-registers))
        (let* ((arg-cont (register-cont node i))
               (arg-code (compile (car args) depth frame arg-cont)))
          (loop (cdr args) 
                (+ i 1) 
                (cons (register-cont-register arg-cont) rev-registers)
                (sequentially code arg-code))))))

;----------------------------------------------------------------
; Pushing arguments.
;
; These are used by the opcode that need stack arguments not registers
; (basically all Call instructions except register-tail-call)
;

(define (push-arguments node args i depth frame)
  (let loop ((args args) (i i) (depth depth) (code empty-segment))
    (if (null? args)
        (begin
          (depth-check! frame depth)
          code)
        (let ((cont (register-cont node i)))
          (loop (cdr args) (+ i 1) (+ depth 1)
            (sequentially
              code
              (compile (car args) depth frame cont)
              (instruction (enum op push) (register-cont-register cont))
              (clear-register-cont frame cont)))))))


;----------------------------------------------------------------
; We have two sizes of these because the big size is very rare and
; signficantly slower (because the argument count cannot be encoded in
; the protocol).

(define (call-instruction proc-register nargs depth frame label)
  (if label
      (if (> nargs maximum-stack-args)				;+++
	  (instruction-using-label (enum op big-call)
				   label
				   proc-register
				   (high-byte nargs)
				   (low-byte nargs))
	  (instruction-using-label (enum op call)
				   label
				   proc-register
				   nargs))
      (if (> nargs maximum-stack-args)				;+++
	  (instruction (enum op big-call)
		       0
		       0
		       proc-register
		       (high-byte nargs)
		       (low-byte nargs))
	  (instruction (enum op tail-call)
	               proc-register
		       nargs))))

;----------------------------------------------------------------
; Register calls avoid the need to first push the values 
; before doing the call.
;
; For tail calls, the benefit is obvious: Without this, the arguments
; would first be pushed on top of the register window and then be moved
; down to the arguments right after. This avoids that extra step.
;
; Although for calls, the register-call instruction does the exact same
; amount of pushes, only inside the call instruction and not as separate
; instructions, it still brings a speed increase due to the reduced
; number of instructions to execute.
; Also when using register-call, there is no need to add a push-false to
; reserve a spot for the continuation on the stack, which further reduces
; the amount of instructions.
;
; The instructions are:
; register-call
; register-tail-call      - assumes registers and target arguments do not overlap
; safe-register-tail-call - can handle overlap between registers and arguments
;

(define (register-call-instruction proc-register depth frame label arg-registers)
  (cond
    (label
     (apply instruction-using-label 
            (enum op register-call)
	    label
	    proc-register
	    (length arg-registers)
	    arg-registers))
    ((argument-register-conflict? arg-registers)
     (apply instruction
            (enum op safe-register-tail-call)
            proc-register
            (length arg-registers)
            arg-registers))
    (else
     (apply instruction
            (enum op register-tail-call)
            proc-register
            (length arg-registers)
            arg-registers))))                                              

(define (argument-register-conflict? arg-registers)
  (let ((nargs (length arg-registers)))
    ;; Check for opverlaps in the indexes:
    ;; Loop through the arguments, and if there is a remaining register index below
    ;; the current argument, then this will be a conflict when copying the arguments
    (let loop ((argument 0) (remaining arg-registers))
      (cond
        ((null? remaining) ;; all is ok      
         #f)
        ((any (lambda (register) (<= register argument)) (cdr remaining)) ;; conflict
         #t)
        (else
         (loop (+ argument 1) (cdr remaining))))))) 

; Make sure the call instructions do not get too long
; - 5 registers as maximum seems to be a good value
; - running the benchmarks with 8 or more as max results in a slight speed decrease
(define (can-do-register-call? nargs)
  (<= nargs 5)) 

;----------------------------------------------------------------
; Compile-time continuations
;
; A compile-time continuation is a pair (kind . source-info).
; Kind is one of the following:
;   'return        - invoke the current full continuation.
;   'ignore-values - ignore values, then fall through.
;   '(register x)  - pass value in the given register, then fall through
;                    if x is #f, compilator must provide a register (can be a non-reusable one)
;                    if x is not #f, compilator must put its output in that register (using move if needed)
; Source-info is one of:
;   #f - we don't know anything
;   symbol - value delivered to subsequent instructions will be assigned to
;     a variable with this name.  If the value being assigned is a lambda, we
;     can give that lambda that name.
;   (i . node) - the value being computed is the i'th subexpression of the node.

(define (make-cont kind source-info) (cons kind source-info))
(define cont-kind car)
(define cont-source-info cdr)


(define (return-cont name)
  (make-cont 'return name))

(define (return-cont? cont)
  (eq? (cont-kind cont) 'return))
  
; Fall through, but provide a register in the cont (using deliver-register-value)  

(define (register-cont node i . maybe-register)
  (if (null? maybe-register)
      (make-cont (cons 'register #f) (cons i node))
      (make-cont (cons 'register (car maybe-register)) (cons i node))))

(define (register-cont? cont)
  (and (pair? (cont-kind cont))
       (eq? (car (cont-kind cont)) 'register)))

(define (set-register-cont-register! cont register)
  (set-cdr! (cont-kind cont) register))

(define (register-cont-register cont)
  (cdr (cont-kind cont)))
  
(define (clear-register-cont frame cont)
  (let ((register (cdr (cont-kind cont))))
    (set-register-cont-register! cont #f)
    (if (eq? register #f) ; do some debugging
        (assertion-violation 'clear-register-cont "compiler-bug: the register-cont has no register set" cont)
        (free-register frame register)))) 

; Ignore return value, then fall through

(define ignore-values-segment
  (bytes->segment (list ignore-values-protocol)))

(define (ignore-values-cont node i)
  (make-cont 'ignore-values (cons i node)))

(define (ignore-values-cont? cont)
  (eq? (cont-kind cont) 'ignore-values))


(define (deliver-register-value segment out-register frame cont)
  (cond
    ((return-cont? cont)
     (free-register frame out-register)
     (sequentially segment
                   (instruction (enum op return) out-register)))
    ((register-cont? cont)
     (if (and (register-cont-register cont)
              (not (= (register-cont-register cont) out-register)))
         (assertion-violation 'deliver-register-value "providing output in the wrong register for this continuation" cont out-register))
     (set-register-cont-register! cont out-register)
     segment)
    ((ignore-values-cont? cont)
     (free-register frame out-register)
     segment)
    (else
     (assertion-violation 'deliver-register-value "unknown compiler continuation" cont))))    


; For putting names to lambda expressions:

(define (named-register-cont name . maybe-register)
  (if (null? maybe-register)
      (make-cont (cons 'register #f) name)
      (make-cont (cons 'register (car maybe-register)) name)))

(define (cont-name cont)
  (if (pair? (cont-source-info cont))
      #f
      (cont-source-info cont)))

;----------------------------------------------------------------
; Utilities

; Find lookup result that was cached by classifier

; The binding property is either a location, a 1- or 2-element list with
; stack index and template index, or 'unbound
(define (name-node-binding node)
  (or (node-ref node 'binding)
      (node-form node)))

; Produce something for source code that contains a compile-time error.

(define (generate-trap depth frame cont . stuff)
  (apply warning 'generate-trap stuff)
  (let ((out-register (get/allocate-out-register frame cont)))    
    (deliver-register-value
      (sequentially
        (register-indirect-instruction
          out-register
          (frame-template-index frame)
          (literal->index frame (cons 'error stuff)))
        (instruction (enum op trap) out-register out-register))
      out-register frame cont)))  
  
;----------------------------------------------------------------
; Type checking.  This gets called on all nodes.

(define (type-check node)
  (if *type-check?*
      (let ((form (node-form node)))
	(if (pair? form)
	    (let ((proc-node (car form)))
	      (if (node? proc-node)
		  (let ((proc-type (node-type proc-node)))
		    (cond ((procedure-type? proc-type)
			   (if (restrictive? proc-type)
			       (let* ((args (cdr form))
				      (args-type (make-some-values-type
						  (map (lambda (arg)
							 (meet-type
							  (node-type arg)
							  value-type))
						       args)))
				      (node (make-similar-node node
							       (cons proc-node
								     args))))
				 (if (not (meet? args-type
						 (procedure-type-domain proc-type)))
				     (diagnose-call-error node proc-type))
				 node)
			       node))
			  ((not (meet? proc-type any-procedure-type))
			   ;; Could also check args for one-valuedness.
			   (let ((message "non-procedure in operator position"))
			     (warning 'type-check
				      message
				      (schemify node)
				      `(procedure: ,proc-type))
			     (node-set! node 'type-error message))
			   node)
			  (else node)))
		  node))
	    node))
      node))

(define (set-type-check?! check?)
  (set! *type-check?* check?))

(define *type-check?* #t)

(define (diagnose-call-error node proc-type)
  (let ((message
	 (cond ((not (fixed-arity-procedure-type? proc-type))
		"invalid arguments")
	       ((= (procedure-type-arity proc-type)
		   (length (cdr (node-form node))))
		"argument type error")
	       (else
		"wrong number of arguments"))))
    (warning 'diagnose-call-error
	     message
	     (schemify node)
	     `(procedure wants:
			 ,(rail-type->sexp (procedure-type-domain proc-type)
					   #f))
	  `(arguments are: ,(map (lambda (arg)
				   (type->sexp (node-type arg) #t))
				 (cdr (node-form node)))))
    (node-set! node 'type-error message)))


; Type system loophole

(define-compilator 'loophole syntax-type
  (lambda (node depth frame cont)
    (compile (caddr (node-form node)) depth frame cont)))

